home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / tdecl / structure.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  12.1 KB  |  338 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; This deals with structure declarations
  3.  
  4. ;;; Each structure declaration creates a number of linked entities.
  5. ;;; Consider:
  6. ;;; structure Bar => Foo where
  7. ;;;   field1 :: Int
  8. ;;;   field2 :: Float
  9. ;;; This must create a class Foo, a constructor function, selector functions,
  10. ;;; a blank,
  11.  
  12. ;;; This performs the initial setup of the structure definition.
  13.  
  14. (define (structure->def struct-decl)
  15.  (remember-context struct-decl
  16.   (with-slots structure-decl (super struct decls) struct-decl
  17.    (mlet ((tycon (get-simple-tycon struct))
  18.       (struct-def (tycon-ref-tycon tycon))
  19.       (tyvars (map (function tyvar-name) (get-simple-args struct)))
  20.       (super-defs '())
  21.       (simple? (null? tyvars))
  22.       (class (structure-class struct-def))
  23.       (slots '())
  24.       (pos 0))
  25.      (setf (structure-simple? struct-def) simple?)
  26.      (dolist (s super)
  27.        (let ((stycon (get-simple-tycon s))
  28.          (args (get-simple-args s)))
  29.      (remember-context stycon
  30.       (when args
  31.             (signal-cant-inherit-polymorphic-structs s struct-def))
  32.       (let ((def (fetch-top-def (tycon-ref-name stycon) 'struct)))
  33.         (unless (structure? def)
  34.           (signal-structure-name-required (tycon-ref-name tycon) def))
  35.         (push def super-defs)))))
  36.      (setf (structure-super struct-def) (reverse super-defs))
  37.      (setf (structure-tyvars struct-def) tyvars)
  38.      (dolist (decl decls)
  39.        (remember-context decl
  40.         (when (is-type? 'signdecl decl)
  41.        (let* ((signature (signdecl-signature decl))
  42.           (vars (resolve-signature signature)))
  43.          (dolist (v vars)
  44.            (when (not (memq v tyvars))
  45.         (signal-bad-structure-component-sig signature v struct)))
  46.          (when (not (null? (signature-context signature)))
  47.          (signal-no-structure-overloading signature struct))
  48.            (dolist (var-ref (signdecl-vars decl))
  49.          (let* ((slot (var-ref-var var-ref))
  50.                 (slot-name (symbol->string (def-name slot))))
  51.           (if simple?
  52.                  (begin (setf (slot-pos slot) pos)
  53.               (incf pos))
  54.            (let* ((getter-name
  55.                (string->symbol (string-append "get-" slot-name)))
  56.               (getter-def (create-top-definition
  57.                        getter-name 'method-var))
  58.               (setter-name
  59.                (string->symbol (string-append "set-" slot-name)))
  60.               (setter-def (create-top-definition
  61.                        setter-name 'method-var)))
  62.               (setf (def-where-defined getter-def)
  63.                 (ast-node-line-number var-ref))
  64.               (setf (def-where-defined setter-def)
  65.                 (ast-node-line-number var-ref))
  66.               (setf (method-var-class getter-def) class)
  67.               (setf (method-var-class setter-def) class)        
  68.               (setf (slot-getter slot) getter-def)
  69.               (setf (slot-setter slot) setter-def)))
  70.            (setf (slot-type slot) (signature-type signature))
  71.            (push slot slots)))))))
  72.       (setf (structure-slots struct-def) (reverse slots))
  73.       struct-def))))
  74.  
  75. (define (expand-structure-definition struct-decl)
  76.  (remember-context struct-decl
  77.   (mlet ((struct (structure-decl-struct struct-decl))
  78.      (decls (structure-decl-decls struct-decl))
  79.      (tycon (get-simple-tycon struct))
  80.      (struct-def (tycon-ref-tycon tycon))
  81.      (simple? (structure-simple? struct-def))
  82.      ((super* slots*)
  83.       (gather-super-structures
  84.        struct-def '() (structure-super struct-def)
  85.                       (structure-slots struct-def))))
  86.     (setf (structure-super* struct-def) super*)
  87.     (setf (structure-slots* struct-def) slots*)
  88.     (create-structure-alg struct-def '())
  89. ; %%% add deriving someday:     (structure-decl-deriving struct-decl))
  90.     (create-empty-structure struct-def)
  91.     (when simple?
  92.     (create-structure-class/instance struct-def))
  93.     (create-structure-init-fn struct-def decls))))
  94.  
  95. ;;; Compute super* and slots* for a structure
  96.  
  97. (define (gather-super-structures top seen to-see all-slots)
  98.   (cond ((null? to-see)
  99.      (values seen all-slots))
  100.     ((eq? (car to-see) top)
  101.      (signal-circular-structs top))
  102.     ((memq (car to-see) seen)
  103.      (gather-super-structures top seen (cdr to-see) all-slots))
  104.     (else
  105.      (gather-super-structures
  106.       top
  107.       (cons (car to-see) seen)
  108.       (append (structure-super (car to-see)) (cdr to-see))
  109.       (append (structure-slots (car to-see)) all-slots)))))
  110.  
  111. ;;; Create a data type for the structure.
  112.  
  113. (define (create-structure-alg struct deriving)
  114.   (let* ((slots (structure-slots* struct))
  115.      (alg (structure-alg struct))
  116.      (tyvars (structure-tyvars struct))
  117.      (con (car (algdata-constrs alg)))
  118.      (constr (make constr
  119.                (constructor (**con/def con))
  120.                (types (map (lambda (x)
  121.                      ;; '() is the annotations
  122.                      (tuple (slot-type x) '()))
  123.                    slots))))
  124.      (alg-decl
  125.       (make data-decl
  126.             (context '())
  127.         (simple (**tycon/def alg (map (function **tyvar) tyvars)))
  128.         (constrs (list constr))
  129.         (deriving deriving)
  130.             (annotations '()))))
  131.     (setf (module-alg-defs *module*)
  132.       (cons (algdata->def alg-decl) (module-alg-defs *module*)))))
  133.  
  134. ;;; This defines an empty structure - all slots contain bottom.  This is used
  135. ;;; by the init code for the structure.  To detect a slot that needs
  136. ;;; defaulting, it is compared to the slot in this structure.
  137.  
  138. (define (create-empty-structure struct)
  139.   (let* ((empty-var (make-new-var
  140.              (string-append
  141.               "empty-" (symbol->string (def-name struct)))))
  142.      (con (structure-con struct))
  143.      (slots (map (lambda (s)
  144.                (**app (**var/def (core-symbol "uninitializedSlot"))
  145.                   (**string (symbol->string (def-name s)))
  146.                   (**string (symbol->string (def-name struct)))))
  147.              (structure-slots* struct))))
  148.     (setf (structure-empty-val struct) empty-var)
  149.     (add-new-module-def empty-var (**app/l (**con/def con) slots))
  150.     slots))
  151.  
  152. ;;; This creates the structure initialization function.  This will be attached
  153. ;;; to the constructor for the structure type.    
  154.  
  155. (define (create-structure-init-fn struct decls)
  156.   (let ((slots* (structure-slots* struct))
  157.     (local-inits '())
  158.     (init-fn-var (make-new-var
  159.               (string-append
  160.                "init-" (symbol->string (def-name struct))))))
  161.     (dolist (decl decls)
  162.       (when (valdef? decl)
  163.     (let ((vars (collect-pattern-vars (valdef-lhs decl))))
  164.       (dolist (var-ref vars)
  165.         (let* ((slot-name (var-ref-name var-ref))
  166.            (slot (resolve-toplevel-name slot-name)))
  167.           (unless (eq? slot *undefined-def*)
  168.            (if (or (not (slot? slot)) (not (memq slot slots*)))
  169.            (signal-init-not-slot struct slot decl)
  170.            (setf local-inits
  171.               (setup-slot-init-fn struct slot var-ref local-inits)))))))
  172.     (add-new-module-decl decl)))
  173.     (let* ((all-inits (find-slot-init-fns slots* local-inits))
  174.        (init-fn (**app (**var/def (core-symbol "doStructureInit"))
  175.                (**var/def (structure-empty-val struct))
  176.                (**tuple all-inits))))
  177.       (add-new-module-def init-fn-var init-fn)
  178.       (setf (structure-init-fn struct) init-fn-var))))
  179.  
  180. ;;; This attached an initialization function to a single slot.  Different
  181. ;;; structs may have different inits for the same slot.
  182.  
  183. (define (setup-slot-init-fn struct slot var-ref local-inits)
  184.   (let ((init-var (make-new-var
  185.            (string-append "init-" (symbol->string (def-name struct))
  186.                   "-" (symbol->string (def-name slot))))))
  187.     (setf (var-ref-var var-ref) init-var)
  188.     (setf (var-ref-name var-ref) (def-name init-var))
  189.     (when (assq slot local-inits)
  190.       (signal-multiple-slot-default slot struct))
  191.     (push (tuple slot init-var) local-inits)
  192.     (when (and (structure-simple? struct) ;; Only set init-fn for local slots
  193.            (memq slot (structure-slots struct)))
  194.        (setf (slot-init-fn slot) init-var))
  195.     (let* ((s-sig (get-struct-type struct))
  196.        (sig (**signature (signature-context s-sig)
  197.                  (**arrow-type
  198.                   (slot-type slot)
  199.                   (signature-type s-sig)
  200.                   (signature-type s-sig)))))
  201.       (add-new-module-signature init-var sig))
  202.     local-inits))
  203.  
  204. ;;; This determines which init function applies to a slot.  Use either
  205. ;;; the definition in the current decl, the one in the defining decl of the
  206. ;;; slot, or none at all.  None at all is indicated by the value False.
  207.  
  208. (define (find-slot-init-fns slots local-inits)
  209.  (if (null? slots)
  210.      '()
  211.      (let* ((slot (car slots))
  212.         (rest (find-slot-init-fns (cdr slots) local-inits))
  213.         (local-fn (assq slot local-inits)))
  214.        (cons
  215.     (if local-fn
  216.         (tuple-2-2 local-fn)
  217.         (or (slot-init-fn slot) (**con/def (core-symbol "False"))))
  218.     rest))))
  219.  
  220. ;;; This returns the type of a structure object
  221.  
  222. (define (get-struct-type struct)
  223.   (if (structure-simple? struct)
  224.       (**signature (list (**context
  225.               (**class/def (structure-class struct))
  226.               '|a|))
  227.            (**tyvar '|a|))
  228.       (**signature '() (**tycon/def struct (map (function **tycon)
  229.                         (structure-tyvars struct))))))
  230.  
  231. ;;; For simple structures, create class and instance decls.   
  232.  
  233. (define (create-structure-class/instance struct)
  234.   (let ((class (structure-class struct)))
  235.     ;; Make this struct an instance of its class and all superclasses.
  236.     (dolist (s (cons struct (structure-super* struct)))
  237.       (add-struct-instance-decl struct s))
  238.     ;; Use `a' to denote the struct type (OK since no polymorphic type here)
  239.     (let* ((super-classes (map (lambda (x)
  240.                  (**context
  241.                   (**class/def (structure-class x))
  242.                   '|a|))
  243.                  (structure-super struct)))
  244.        ;; Each slot has two methods: getter and setter.
  245.        (decls (concat (map (lambda (s)
  246.                  (list
  247.                   (**signdecl/def
  248.                    (list (slot-getter s))
  249.                    (**signature '()
  250.                        (**arrow-type
  251.                     (**tyvar '|a|)
  252.                     (slot-type s))))
  253.                   (**signdecl/def
  254.                    (list (slot-setter s))
  255.                    (**signature '()
  256.                       (**arrow-type
  257.                        (slot-type s)
  258.                        (**tyvar '|a|)
  259.                        (**tyvar '|a|))))))
  260.                    (structure-slots struct))))
  261.        (class-decl (make class-decl
  262.                 (class (**class/def class))
  263.                 (super-classes super-classes)
  264.                 (class-var '|a|)
  265.                 (decls decls))))
  266.       (class->def class-decl)
  267.       (push class (module-class-defs *module*)))))
  268.  
  269. ;;; Put a structure into a class.
  270.  
  271. (define (add-struct-instance-decl struct i-struct)
  272.   (let ((i-defs '())
  273.     (con (structure-con struct)))
  274.     (dolist (s (structure-slots i-struct))
  275.       (let ((i (get-slot-position s struct)))
  276.     (push (**define (slot-getter s) '(|x|) (**sel con (**var '|x|) i))
  277.           i-defs)
  278.     (push (**define (slot-setter s) '(|x|) (**update con (list (**var '|x|))
  279.                                    (list i)))
  280.           i-defs)))
  281.     (let ((res (make instance-decl
  282.              (context '())
  283.              (class (**class/def (structure-class i-struct)))
  284.              (simple (**tycon/def (structure-alg struct) '()))
  285.              (decls i-defs))))
  286.       (push res (module-instance-defs *module*)))))
  287.  
  288. (define (get-slot-position slot struct)
  289.   (get-slot-position-1 slot (structure-slots* struct) 0))
  290.  
  291. (define (get-slot-position-1 slot slots i)
  292.   (if (null? slots)
  293.       (error "Non-existent slot!")
  294.       (if (eq? slot (car slots))
  295.       i
  296.       (get-slot-position-1 slot (cdr slots) (1+ i)))))
  297.  
  298. (define (structure-con s)
  299.   (car (algdata-constrs (structure-alg s))))
  300.  
  301. ;;; Error handlers
  302.  
  303. (define (signal-cant-inherit-polymorphic-structs s struct-def)
  304.   (phase-error/objs 'poly-superstruct (list struct-def)
  305.     "The polymorphic structure ~A cannot be used as a super structure of ~A"
  306.     s (get-object-name struct-def)))
  307.  
  308. (define (signal-structure-name-required name def)
  309.   (phase-error/objs 'superstruct-not-structure (list def)
  310.      "The inherited structure ~A of ~A is not a structure"
  311.      name (get-object-name def)))
  312.  
  313. (define (signal-bad-structure-component-sig signature v struct)
  314.   (phase-error/objs 'bad-struct-tyvar (list struct)
  315.  "The type variable ~A in the signature ~A must be a parameter to structure ~A"
  316.       v signature (get-object-name struct)))
  317.  
  318. (define (signal-no-structure-overloading signature struct)
  319.   (phase-error/objs 'bad-struct-overloading (list struct)
  320.    "The signature ~A must not contain overloaded type variables in~%~
  321.     the definition of to structure ~A"
  322.     signature (get-object-name struct)))
  323.  
  324. (define (signal-circular-structs s)
  325.   (phase-error/objs 'circular-super-structs (list s)
  326.     "The structure ~A inherits itself."
  327.     (get-object-name s)))
  328.  
  329. (define (signal-init-not-slot struct slot decl)
  330.   (phase-error/objs 'default-not-a-slot (list struct)
  331.     "~A is not a slot in ~A in the default definition ~A"
  332.     slot (get-object-name struct) decl))
  333.  
  334. (define (signal-multiple-slot-default slot struct)
  335.   (phase-error/objs 'multiple-struct-default (list struct)
  336.     "~A has multiple default definitions in ~A"
  337.     slot (get-object-name struct)))
  338.